home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / xscm.lha / xscm / olsubs.scm < prev    next >
Encoding:
Text File  |  1992-08-29  |  3.2 KB  |  102 lines
  1. ; $Header: /home/campbell/Languages/Scheme/scm/x-scm/RCS/olsubs.scm,v 1.2 1992/07/04 05:02:17 campbell Beta $
  2. ;
  3. ; Generally useful OpenLook (OLIT) functions
  4. ;
  5. ;  Author: Larry Campbell (campbell@redsox.bsw.com)
  6. ; 
  7. ;  Copyright 1992 by The Boston Software Works, Inc.
  8. ;  Permission to use for any purpose whatsoever granted, as long
  9. ;  as this copyright notice remains intact.  Please send bug fixes
  10. ;  or enhancements to the above email address.
  11.  
  12. (require (in-vicinity (library-vicinity) "assert.scm"))
  13.  
  14. ; Create a text widget with a caption to its left.  Returns the
  15. ; text widget's ID.
  16. ;
  17. (define (make-captioned-text-widget parent label columns . args)
  18.   #.(assert '(string? label))
  19.   #.(assert '(integer? columns))
  20.   (let* ((caption
  21.       (xt:create-managed-widget
  22.        label ol:caption parent
  23.        xt:n-label label))
  24.      (text
  25.       (xt:create-managed-widget
  26.        "text" ol:text-field caption)))
  27.     text))
  28.  
  29. (define (make-button label parent action)
  30.   (let ((widget
  31.      (xt:create-managed-widget
  32.       label
  33.       ol:oblong-button
  34.       parent)))
  35.     (xt:add-callback widget xt:n-select action)
  36.     widget))
  37.  
  38. ; (make-pulldown-menu name parent (label1 action1) (label2 action2)...)
  39.  
  40. (define (make-pulldown-menu name parent . args)
  41.   (let* ((widget (xt:create-managed-widget
  42.           name
  43.           ol:menu-button
  44.           parent))
  45.      (menu-widget (xt:get-value widget "menuPane" xt:widget)))
  46.     (do ((items args (cdr items)))
  47.     ((null? items) widget)
  48.         (let* ((item (car items))
  49.                   (label (car item))
  50.            (action (cadr item)))
  51.       (make-button label menu-widget action)))))
  52.  
  53.  
  54. (define (popup-information parent message)
  55.   #.(assert '(string? message))
  56.   (let ((nshell (xt:create-popup-shell
  57.           "information" ol:notice-shell parent
  58.           xt:n-emanate-widget parent)))
  59.     (let ((ca (xt:get-value nshell xt:n-control-area xt:widget))
  60.       (ta (xt:get-value nshell xt:n-text-area xt:widget)))
  61.       (xt:set-values ta xt:n-string message)
  62.       (make-button "OK" ca (lambda _ (xt:destroy-widget nshell))))
  63.     (xt:popup nshell 1)))
  64.  
  65.  
  66. ; Create a row of evenly-spaced buttons (typically used for the
  67. ; "OK" "Apply" "Cancel" buttons at the bottom of a panel).
  68. ; Returns nothing.
  69. ; 
  70. ; Usage:
  71. ;   (make-button-row parent '(("label 1" action1) ("label 2" action2)))
  72. ;
  73. (define (make-button-row parent button-specifiers)
  74.   #.(assert '(list? button-specifiers))
  75.   (let ((ca (xt:create-managed-widget
  76.          "ca" ol:control-area parent))
  77.     (parent-width (xt:get-value parent xt:n-width xt:integer)))
  78.     (if (=? 0 parent-width)
  79.     (error "button-row: parent has zero width"))
  80.     (do ((items button-specifiers (cdr items)))
  81.     ((null? items) ca)
  82.       (let* ((item (car items))
  83.          (label (car item))
  84.          (action (cadr item))
  85.          (button '()))
  86.     (case label
  87.       ((xm:arrow-up xm:arrow-down xm:arrow-left xm:arrow-right)
  88.        (set! button (xt:create-managed-widget
  89.              "arrow" xm:arrow-button-gadget ca
  90.              xm:n-arrow-direction
  91.              (case label
  92.                  ((xm:arrow-down) xm:arrow-down)
  93.                  ((xm:arrow-up) xm:arrow-up)
  94.                  ((xm:arrow-left) xm:arrow-left)
  95.                  ((xm:arrow-right) xm:arrow-right))
  96.              xm:n-traversal-on #f)))
  97.       (else
  98.        (set! button (xt:create-managed-widget
  99.              label ol:oblong-button-gadget ca))))
  100.     (xt:add-callback button xt:n-select action)))))
  101.  
  102.